Pensieve Header: A second attempt at the "infinitesimal Alexander module"; continues 2008-09/AlexanderEulerSpaces.nb.

<< KnotTheory`

(#-> Alexander[#][t])& /@ AllKnots[{3,7}]

K=Knot[4,1];
pd = PD[K];
gc=GC @@ pd /. X[i_,j_,k_,l_] :> If[PositiveQ[X[i,j,k,l]],
Ar[l,i,+1], Ar[j,i,-1]
];
False&& (gc = GC[Ar[1,3, +1], Ar[4,2,-1]]);
n = 2 Length[gc];
gc

Conventions for red objects:
  1. Legs start just to the right of the index; RedAr[0,7] means a red arrow starting to the right of position 0 (that is, to the left of everything) and ending to the right of position 7).
  2. If two (red) indices are the same, the heads are to the right of the tails.
  3. RedW[] is the legless wheel object.
  3. RedY[i,j,k] means "red Y with tails are i and j and head at k".

range=Range[0,n];
AllRedObjects=Flatten[{
Outer[RedAr, range, range], Outer[RedY, range, range, range], RedW[]
}];
Short[AllRedObjects]

The relations associated with a red objects involve all the ways of "pulling one leg one unit to the left" :

RelationsIn[gc_GC, red_] := ReplaceList[
red*(Times @@ Select[gc, (Intersection[List@@#, List@@red] =!= {})&]), {
(* Short red arrows are central: *)
(* RedAr[i_, i_]*_. /; i> 0 :> -red+RedAr[i-1, i-1], *)
(* Tails commute for RedAr: *)
RedAr[i_, j_]Ar[i_,_, _]*_. :> -red+RedAr[i-1, j]+If[i-1==j, -x RedW[], 0],
(* Commuting a RedAr tail across an Ar head *)
RedAr[i_,j_]Ar[k_, i_, s_]*_. :> -red +RedAr[i-1,j]+(X^s-1)/x RedY[k,i,j]+If[i-1==j, -x RedW[], 0],
(* Commuting the head of a RedAr with the tail of an Ar *)
RedAr[i_,j_]Ar[j_, k_, s_]*_. :> -red + RedAr[i,j-1]+(X^s-1)/x RedY[j,i,k-1]+If[i==j, x RedW[], 0],
(* Commuting the head of a RedAr with the head of an Ar *)
RedAr[i_,k_]Ar[j_, k_, s_]*_. :> -red + RedAr[i,k-1]-(X^s-1)/x RedY[j,i,k-1]+If[i==k, x RedW[], 0],
(* The anti-symmetry of RedY: *)
RedY[i_, j_, k_] * _. :> red + RedY[j,i,k],
(* Tails commute for RedY: *)
RedY[i_, j_, k_]Ar[i_,_, _]*_. :> -red+RedY[i-1, j, k]+If[i-1==k, x^2 RedW[], 0],
RedY[i_, j_, k_]Ar[j_,_, _]*_. :> -red+RedY[i, j-1, k]+If[j-1==k, -x^2 RedW[], 0],
(* Commuting a RedY tail across an Ar head *)
RedY[i_,j_,k_]Ar[l_, j_, s_]*_. :> -red +RedY[i,j-1,k]-(X^s-1) RedY[l,j,k]+If[j-1==k, -x^2 RedW[], 0],
(* Commuting a RedY head across an Ar tail *)
RedY[i_,j_,k_]Ar[k_,l_,s_]*_. :> -red+ RedY[i,j,k-1]-(X^s-1) RedY[i,j,l-1] - (
If[i==k, x^2RedW[], 0]+If[j==k, -x^2RedW[],0]
),
(* Commuting a RedY head across an Ar head *)
RedY[i_,j_,l_]Ar[k_,l_,s_]*_. :> -red+ RedY[i,j,l-1]+(X^s-1) RedY[i,j,l-1] - (
If[i==l, x^2RedW[], 0]+If[j==l, -x^2RedW[],0]
)
}
]

AllRedRelations = Flatten[RelationsIn[gc, #]& /@ AllRedObjects];
rule = Thread[Rule[AllRedObjects, IdentityMatrix[Length[AllRedObjects]]]];
Short[RedRules=Map[
(
p = First@Part[AllRedObjects, First@Position[#, 1, {1}]];
p -> p-(#.AllRedObjects)
)&,
DeleteCases[mat=Simplify[RowReduce[AllRedRelations /. rule]], {0...}]
]]

Simplify[RedRules[[Table[Random[Integer, {1,Length[RedRules]}], {10}]]]]

RedZ=Plus @@ gc /. Ar[i_, j_, s_] :> s*RedAr[i,j]

Simplify[RedZ /. RedRules]